home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / source / ProjectOberon / AmigaSupport.mod < prev    next >
Text File  |  1995-07-02  |  8KB  |  282 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: AmigaSupport.mod $
  4.   Description: Amiga-specific support for Project Oberon modules.
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 1.3 $
  8.       $Author: fjc $
  9.         $Date: 1995/06/04 23:24:07 $
  10.  
  11.   Copyright © 1995, Frank Copeland.
  12.   This file is part of the Oberon-A Library.
  13.   See Oberon-A.doc for conditions of use and distribution.
  14.  
  15. *************************************************************************)
  16.  
  17. <*STANDARD-*> <* MAIN-*>
  18.  
  19. MODULE AmigaSupport;
  20.  
  21. IMPORT
  22.   SYS := SYSTEM, Kernel, Errors, s := Sets, e := Exec, es := ExecSupport,
  23.   u := Utility, gfx := Graphics, i := Intuition, gt := GadTools,
  24.   ASL, rt := ReqTools, iu := IntuiUtil, df := DiskFont;
  25.  
  26. (*------------------------------------*)
  27. VAR
  28.   scr -: i.ScreenPtr;
  29.   scrFont -: gfx.TextFontPtr;
  30.   win -: i.WindowPtr;
  31.   W -, H -: INTEGER;
  32.  
  33.   KeyProc*, MouseProc*, TickProc* : PROCEDURE (msg : i.IntuiMessagePtr);
  34.  
  35.   oldRegion : gfx.RegionPtr; (* for clipping *)
  36.   screenDrawInfo : i.DrawInfoPtr;
  37.   attr : gfx.TextAttr;
  38.  
  39.  
  40. (*------------------------------------*)
  41. CONST
  42.   pubScreenName = "";
  43.   scrTitle = "Display inactive";
  44.   winTitle = "Display for Project Oberon modules";
  45.   idcmp = {i.vanillaKey, i.mouseButtons, i.intuiTicks};
  46.  
  47.  
  48. (*------------------------------------*)
  49. PROCEDURE OpenScreen;
  50.  
  51.   (*------------------------------------*)
  52.   PROCEDURE CloneScreen;
  53.  
  54.     VAR
  55.       screenModeID : LONGINT;
  56.       pubScreen : i.ScreenPtr;
  57.  
  58.   BEGIN (* CloneScreen *)
  59.     scrFont := NIL;
  60.     pubScreen := i.LockPubScreen (pubScreenName);
  61.     IF pubScreen # NIL THEN
  62.       screenDrawInfo := i.GetScreenDrawInfo (pubScreen);
  63.       IF screenDrawInfo # NIL THEN
  64.         screenModeID := gfx.GetVPModeID (SYS.ADR (pubScreen.viewPort));
  65.         IF screenModeID # gfx.invalidID THEN
  66.           scr := i.OpenScreenTagsA
  67.             ( NIL,
  68.               i.saWidth,       pubScreen.width,
  69.               i.saHeight,      pubScreen.height,
  70.               i.saDepth,       screenDrawInfo.depth,
  71.               i.saOverscan,    i.oScanText,
  72.               i.saAutoScroll,  i.LTRUE,
  73.               i.saFullPalette, i.LTRUE,
  74.               i.saPens,        screenDrawInfo.pens,
  75.               i.saSysFont,     1,
  76.               i.saDisplayID,   screenModeID,
  77.               i.saTitle,       SYS.ADR (scrTitle),
  78.               u.end );
  79.           i.FreeScreenDrawInfo (pubScreen, screenDrawInfo);
  80.           screenDrawInfo := NIL;
  81.           i.UnlockPubScreen (pubScreenName, pubScreen);
  82.           pubScreen := NIL;
  83.           IF scr # NIL THEN
  84.             screenDrawInfo := i.GetScreenDrawInfo (scr);
  85.             IF screenDrawInfo # NIL THEN scrFont := screenDrawInfo.font
  86.             ELSE scrFont := gfx.base.defaultFont
  87.             END
  88.           END
  89.         END
  90.       END
  91.     END;
  92.     ASSERT (scr # NIL, Errors.postCondition)
  93.   END CloneScreen;
  94.  
  95.  
  96.   (*------------------------------------*)
  97.   PROCEDURE ReqToolsScreen;
  98.  
  99.     VAR
  100.       scrMdReq : rt.ScreenModeRequesterPtr; result : BOOLEAN;
  101.       displayID, autoScroll : LONGINT;
  102.       displayWidth, displayHeight, displayDepth(*, overscanType*) : INTEGER;
  103.       fontReq : rt.FontRequesterPtr;
  104.       (*attr : gfx.TextAttr;*) fontTag : u.TagID; fontData : u.Tag;
  105.  
  106.   BEGIN (* ReqToolsScreen *)
  107.     scrMdReq :=
  108.       SYS.VAL (rt.ScreenModeRequesterPtr,
  109.         rt.AllocRequest ( rt.TypeScreenModeReq, u.end ));
  110.     ASSERT (scrMdReq # NIL, Errors.postCondition);
  111.     result :=
  112.       rt.ScreenModeRequest
  113.         ( scrMdReq, "Choose a screen mode",
  114.           rt.scFlags, { rt.scReqSizeGads, rt.scReqDepthGad,
  115.                         rt.scReqGuiModes, rt.scReqAutoscrollGad },
  116.           u.end );
  117.     IF result THEN
  118.       displayID := scrMdReq.displayID;
  119.       displayWidth := scrMdReq.displayWidth;
  120.       displayHeight := scrMdReq.displayHeight;
  121.       displayDepth := scrMdReq.displayDepth;
  122.       (* overscanType := scrMdReq.overscanType; *)
  123.       autoScroll := scrMdReq.autoScroll;
  124.       rt.FreeRequest (scrMdReq);
  125.  
  126.       fontReq :=
  127.         SYS.VAL (rt.FontRequesterPtr,
  128.           rt.AllocRequest ( rt.TypeFontReq, u.end ));
  129.       ASSERT (fontReq # NIL, Errors.postCondition);
  130.       result := rt.FontRequest ( fontReq, "Choose a font", u.end );
  131.       IF result THEN
  132.         attr := fontReq.attr;
  133.         SYS.NEW (attr.name, SYS.STRLEN (fontReq.attr.name^) + 1);
  134.         COPY (fontReq.attr.name^, attr.name^);
  135.         fontTag := i.saFont; fontData := SYS.ADR (attr)
  136.       ELSE
  137.         fontTag := i.saSysFont; fontData := 1
  138.       END;
  139.       rt.FreeRequest (fontReq);
  140.  
  141.       scr := i.OpenScreenTagsA
  142.         ( NIL,
  143.           i.saWidth,       displayWidth,
  144.           i.saHeight,      displayHeight,
  145.           i.saDepth,       displayDepth,
  146.           i.saAutoScroll,  autoScroll,
  147.           i.saDisplayID,   displayID,
  148.           fontTag,         fontData,
  149.           i.saTitle,       SYS.ADR (scrTitle),
  150.           (* i.saOverscan,    overscanType, *)
  151.           i.saOverscan,    i.oScanText,
  152.           i.saFullPalette, i.LTRUE,
  153.           u.end )
  154.     ELSE
  155.       rt.FreeRequest (scrMdReq);
  156.       CloneScreen
  157.     END;
  158.     ASSERT (scr # NIL, Errors.postCondition)
  159.   END ReqToolsScreen;
  160.  
  161. BEGIN (* OpenScreen *)
  162.   rt.OpenLib (FALSE);
  163.   IF rt.base # NIL THEN ReqToolsScreen
  164.   ELSE CloneScreen
  165.   END;
  166.   screenDrawInfo := i.GetScreenDrawInfo (scr);
  167.   IF screenDrawInfo # NIL THEN scrFont := screenDrawInfo.font
  168.   ELSE scrFont := gfx.base.defaultFont
  169.   END
  170. END OpenScreen;
  171.  
  172.  
  173. (*------------------------------------*)
  174. PROCEDURE CloseScreen ();
  175. BEGIN (* CloseScreen *)
  176.   IF scr # NIL THEN
  177.     IF screenDrawInfo # NIL THEN
  178.       i.FreeScreenDrawInfo (scr, screenDrawInfo); screenDrawInfo := NIL
  179.     END;
  180.     i.OldCloseScreen (scr); scr := NIL
  181.   END
  182. END CloseScreen;
  183.  
  184.  
  185. (*------------------------------------*)
  186. PROCEDURE OpenWindow ();
  187. BEGIN (* OpenWindow *)
  188.   win := i.OpenWindowTagsA ( NIL,
  189.       i.waCustomScreen, scr,
  190.       i.waTop,          scr.barHeight + scr.barVBorder,
  191.       i.waHeight,       scr.height - scr.barHeight - scr.barVBorder,
  192.       i.waActivate,     i.LTRUE,
  193.       i.waBorderless,   i.LTRUE,
  194.       i.waBackdrop,     i.LTRUE,
  195.       i.waRMBTrap,      i.LTRUE,
  196.       i.waScreenTitle,  SYS.ADR (winTitle),
  197.       i.waIDCMP,        idcmp,
  198.       u.end );
  199.   ASSERT (win # NIL, Errors.postCondition);
  200.   ASSERT (iu.ClipWindowToBorders (win, oldRegion), Errors.postCondition)
  201. END OpenWindow;
  202.  
  203.  
  204. (*------------------------------------*)
  205. PROCEDURE CloseWindow ();
  206. BEGIN (* CloseWindow *)
  207.   IF win # NIL THEN
  208.     iu.UnclipWindow (win, oldRegion); oldRegion := NIL;
  209.     i.CloseWindow (win); win := NIL
  210.   END;
  211. END CloseWindow;
  212.  
  213.  
  214. (*------------------------------------*)
  215. PROCEDURE OpenDisplay *;
  216. BEGIN (* OpenDisplay *)
  217.   IF scr = NIL THEN
  218.     OpenScreen();
  219.     OpenWindow();
  220.     W := win.width - win.borderLeft - win.borderRight;
  221.     H := win.height - win.borderTop - win.borderBottom;
  222.   END
  223. END OpenDisplay;
  224.  
  225.  
  226. (*------------------------------------*)
  227. PROCEDURE GetNextEvent*;
  228.  
  229.   VAR
  230.     msg : i.IntuiMessagePtr;
  231.     signals : s.SET32;
  232.     sigBit : SHORTINT;
  233.  
  234. BEGIN (* GetNextEvent *)
  235.   (* We only have one signal bit, so we do not have to check which
  236.   ** bit broke the Wait().
  237.   *)
  238.   signals := e.Wait ({win.userPort.sigBit});
  239.   LOOP
  240.     msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (win.userPort));
  241.     IF msg = NIL THEN EXIT END;
  242.     IF (msg.class = {i.vanillaKey})
  243.     OR (msg.class = {i.rawKey})
  244.     THEN
  245.       IF KeyProc # NIL THEN KeyProc (msg) END;
  246.     ELSIF msg.class = {i.mouseButtons} THEN
  247.       IF MouseProc # NIL THEN MouseProc (msg) END;
  248.     ELSIF msg.class = {i.intuiTicks} THEN
  249.       IF TickProc # NIL THEN TickProc (msg) END;
  250.     END;
  251.     e.ReplyMsg (msg)
  252.   END;
  253. END GetNextEvent;
  254.  
  255.  
  256. (*------------------------------------*)
  257. PROCEDURE BeginUpdate*;
  258. BEGIN (* BeginUpdate *)
  259. END BeginUpdate;
  260.  
  261.  
  262. (*------------------------------------*)
  263. PROCEDURE EndUpdate*;
  264. BEGIN (* EndUpdate *)
  265. END EndUpdate;
  266.  
  267.  
  268. (*------------------------------------*)
  269. PROCEDURE* Close ( VAR rc : LONGINT );
  270. BEGIN (* Close *)
  271.   CloseWindow();
  272.   CloseScreen();
  273. END Close;
  274.  
  275. (*------------------------------------*)
  276. <*$ClearVars+*>
  277. BEGIN
  278.   Errors.Init;
  279.   ASSERT (gt.base # NIL, 100);
  280.   Kernel.SetCleanup (Close)
  281. END AmigaSupport.
  282.